home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / mapping.lisp < prev    next >
Text File  |  1993-07-17  |  4KB  |  114 lines
  1. ;;; -*- Mode: LISP; Package: BOXER; Syntax: Zetalisp -*-
  2.  
  3. ;;; (C) Copyright 1985 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; Permission to use, copy, modify, distribute, and sell this software
  6. ;;; and its documentation for any purpose is hereby granted without fee,
  7. ;;; provided that the above copyright notice appear in all copies and that
  8. ;;; both that copyright notice and this permission notice appear in
  9. ;;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;;; advertising or publicity pertaining to distribution of the software
  11. ;;; without specific, written prior permission.  M.I.T. makes no
  12. ;;; representations about the suitability of this software for any
  13. ;;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;;
  15.  
  16. ;;; Mapping functions for databases in Boxer.
  17.  
  18.  
  19. (defboxer-function bu::for-all-boxes ((datafy doit-box-or-name) (port-to box))
  20.   (let* ((thing (get-first-element doit-box-or-name))
  21.      (function (if (symbolp thing)
  22.                (boxer-symeval thing)
  23.                thing))
  24.      (arglist (if (box? function)
  25.               (boxer-arglist function)
  26.               (get-template function)))
  27.      (port-flavor? (and (listp (car arglist))
  28.                 (or (eq 'bu::port-to (caar arglist))
  29.                 (eq :port-to (caar arglist))))))
  30.     (map-over-inferior-boxes
  31.       (get-port-target box)
  32.       #'(lambda (arg)
  33.       (boxer-funcall function (if port-flavor? arg (copy-box arg nil)))))))
  34.  
  35. ;;; this is kind of a crock.  the both predicate gets run in the lexical environment
  36. ;;; of the box if it has no inputs or gets the box as an input if it wants an input. 
  37. ;;; that's because tell is so useless.
  38. (defboxer-function bu::collect-from-all-boxes ((datafy doit-box-or-name) (port-to box))
  39.   (make-box
  40.     (with-collection
  41.       (let* ((thing (get-first-element doit-box-or-name))
  42.          (function (if (symbolp thing)
  43.                (boxer-symeval thing)
  44.                thing))
  45.          (arglist (if (box? function)
  46.               (boxer-arglist function)
  47.               (get-template function)))
  48.          (port-flavor? (and (listp (car arglist))
  49.                 (or (eq 'bu::port-to (caar arglist))
  50.                     (eq :port-to (caar arglist))))))
  51.     (map-over-inferior-boxes
  52.       (get-port-target box)
  53.       #'(lambda (arg)
  54.           (let ((result 
  55.               (if arglist
  56.               (boxer-funcall
  57.                 function
  58.                 (if port-flavor? arg (copy-box arg nil)))
  59.               (with-static-root-bound arg (boxer-funcall function)))))
  60.         (unless (memq result *returned-values-not-to-print*)
  61.           (collect (list result))))))))))
  62.  
  63. (defboxer-function bu::collect-template-from-all-boxes ((port-to box) template)
  64.   (make-box
  65.     (with-collection
  66.       (map-over-inferior-boxes
  67.     (get-port-target box)
  68.     #'(lambda (arg)
  69.         (collect
  70.           (let ((result (with-static-root-bound arg (build-internal template))))
  71.         (if (evbox? result)
  72.             (get-evbox-elements result)
  73.             (box-items-list result)))))))))
  74.  
  75. ;;; this is kind of a crock.  the both predicate gets run in the lexical environment
  76. ;;; of the box if it has no inputs or gets the box as an input if it wants an input. 
  77. ;;; that's because tell is so useless.
  78. (defboxer-function bu::collect-template-from-some-boxes ((datafy predicate)
  79.                              template
  80.                              (port-to box))
  81.   (let* ((predicate (get-first-element predicate))
  82.      (function (if (symbolp predicate)
  83.                (boxer-symeval predicate)
  84.                predicate))
  85.      (arglist (cond ((doit-box? function)
  86.              (boxer-arglist function))
  87.             ((functionp function) (get-template function))
  88.             (t nil)))
  89.      (port-flavor? t))
  90.     ;; (and (listp (car arglist))
  91.     ;;      (or (eq 'bu::port-to (caar arglist))
  92.     ;;          (eq :port-to (caar arglist)))))
  93.     (make-box
  94.       (with-collection
  95.     (map-over-inferior-boxes
  96.       (get-port-target box)
  97.       #'(lambda (arg)
  98.           (when (cond ((true? predicate) t)
  99.               ((null arglist) 
  100.                (with-static-root-bound arg
  101.                  (true? (boxer-funcall function))))
  102.               (t (true? (boxer-funcall
  103.                       function
  104.                       (if port-flavor? arg (copy-box arg nil))))))
  105.         (collect
  106.           (let ((result (with-static-root-bound arg
  107.                   (build-internal template))))
  108.             (if (evbox? result)
  109.             (get-evbox-elements result)
  110.             (box-items-list result)))))))))))
  111.  
  112. (defboxer-function bu::self ()
  113.   (make-port-to *boxer-static-variables-root*))
  114.